;;;; 2007-05-05 01:40:32
;;;; Behold, the power of lisp.



;;; Use a the genes describe the direction to travel at each point
;;; Every allele applies as follows
;;;   10s place is the x coordinate
;;;    1s place is the y coordinate
;;;       append the fraction to the given place
;;; To select a direction mod 4 the value at the location * 10

(defun genes-to-map (genes)
  (let ((result (make-array '(10 10) :initial-element 0.)))
    (dolist (g genes)
      (setf (aref result (floor g 10) (mod (floor g 1) 10))
            (+ (aref result (floor g 10) (mod (floor g 1) 10))
               (mod g 1))))
    result))


;;;
;;; Test by walking the policy from a random point along the policy
;;;   Stop at goal or wall or reaching a previously found site  
;;;     If goal reached steps to goal Value is the 100 - steps 
;;;   If hits a wall -1
;;;   If hits previously found site 0

(defparameter walk-found (make-array '(10 10)))
(defparameter walk-found-key 0)

(defun walk-map (m x y)
  (let ((found-key walk-found-key)
        (steps 0)
        (at-val nil))
    (setf walk-found-key (mod (1+ walk-found-key) 1000))
    (loop 
      (if (or (> x 9) (< x 0) (> y 9) (< y 0))
          (return 5)
          (if (and (= x 9) (= y 0))
              (return (- steps 50))
              (if (= found-key (aref walk-found x y))
                  (return 3)
                  (progn
                    (setf steps (1+ steps))
                    (setf (aref walk-found x y) found-key)
                    (if (= 0 (aref m x y))
                        (return 2);(setf at-val (random 4))
                        (setf at-val (floor (mod (* 40 (aref m x y)) 4) 1)))
                    (if (= 0 at-val)
                        ;(progn (format t "Going right~%") 
                               (setf x (1+ x));)
                        (if (= 1 at-val)
                            ;(progn (format t "Going left~%") 
                            (setf x (1- x));)
                            (if (= 2 at-val)
                                ;(progn (format t "Going down~%") 
                                (setf y (1+ y));)
                                ;(progn (format t "Going up~%") 
                                (setf y (1- y))))))))))));)
                                  

(defun gen-pol-str (pol x y)
  (if (= 0 (aref pol x y))
      (format nil "?")
      (let ((at-val (floor (mod (* 40 (aref pol x y)) 4) 1)))
        (if (= 0 at-val)
            (format nil "R")
            (if (= 1 at-val)
                (format nil "L")
                (if (= 2 at-val)
                    (format nil "D")
                    (format nil "U")))))))
  
(defun print-policy (pol &optional (to t))
  (let ((result ""))
    (dotimes (i (array-dimension pol 0))
      (progn
        (setf result (concatenate 'string result (format to "~%" nil)))
        (dotimes (j (array-dimension pol 1))
          (setf result (concatenate 'string result (format to "~a " (gen-pol-str pol j i)))))))
    result))

(defun test-optimal-grid (policy)
  "Tests whether a given grid policy as an optimal one"
  (let ((result 1))
  ;Test top row
    (dotimes (i (array-dimension policy 0))
      (if (not (equal "R" (gen-pol-str policy i 0)))
          (setf result nil)))
  ;Test right column
    (dotimes (i (array-dimension policy 1))
      (if (not (equal "U" (gen-pol-str policy 9 i)))
          (setf result nil)))
  ;Test middle grid
    (dotimes (i (array-dimension policy 0))
      (dotimes (j (array-dimension policy 1))
        (if (not (or (equal "U" (gen-pol-str policy j i)) (equal "R" (gen-pol-str policy j i))))
            (setf result nil))))
    result))
            
    

;; Makes a population of single gene string genes to be used with the grid searching
(defun make-grid-population (count pop-size)
  (let ((result nil)
        (cur nil))
    (dotimes (i pop-size)
      (setf cur nil)
      (dotimes (k count)
        (push (random 100.0) cur))
      (push cur result))
    result))

;; Crossover takes a point on each list and cuts it and appends it to the other one
(defun cut-splice-crossover (parent1 parent2)
  (let ((result nil)
        (left (random (length parent1))))
    (dolist (p parent1)
      (if (<= left 0)
          (return result)
          (progn
            (setf left (1- left))
            (push p result))))
    (append (nreverse result) (nthcdr (random (length parent2)) parent2))))
        
(defun mut-cut-splice-crossover (parent1 parent2 &optional (rate 0.0))
  (let ((child (cut-splice-crossover parent1 parent2)))
    (dolist (c child)
      (if (< (random 1.0) rate)
          (setf c (random 100.0))))
    child))

(defun genes-val (genes &optional (test-points nil))
  (let ((result 0)
        (grid (genes-to-map genes)))
    (if (null test-points)
        (dotimes (i 10)
          (dotimes (k 10)
            (setf result (+ result (walk-map grid i k)))))
        (dolist (p test-points)
          (setf result (+ result (walk-map grid (car p) (cadr p))))))
    result))
        
  

(defun run-gene-grid (&optional 
                       (generations 1000)
                       (test-runs 5) 
                       (pop-size 100) 
                       (start-gene-length 100) 
                       (repro-policy nil))
  (let ((pop (make-grid-population start-gene-length pop-size))
        (sorted-pop nil)
        (test-points nil))
    (if (null repro-policy)
        (setf repro-policy (make-generation-policy
                             :eval-func #'genes-val
;                             #'(lambda (a)
 ;                                           (let ((result 0)
  ;                                                (a-map (genes-to-map a)))
   ;                                           ;(format t "Evaluating ~a~%" (print-policy a-map nil))
    ;                                          (dolist (p test-points)
     ;                                           (setf result (+ result (walk-map a-map (car p) (cadr p) ))))
      ;                                        result))
                             :crossover-func #'mut-cut-splice-crossover
                             :elite 0.05
                             :cull 0.2
                             :rand 0.01)))
                             ;:crossover-func #'uniform-crossover)))
    (dotimes (i generations)
      (setf test-points nil)
      (dotimes (r 10) (dotimes (s 10) (push (list r s) test-points)))
      
      (format t " g~A" i)
      (setf sorted-pop (eval-sort-population pop (generation-policy-eval-func repro-policy)))
      ;Test for optimal
      (format t " best:~a~%" (genes-val (car (car sorted-pop))) nil)
      (if (test-optimal-grid (genes-to-map (car (car sorted-pop))))
          (progn
            (format t "~%Found optimal, generation: ~A~%" i)
            (return (car (car sorted-pop)))))
      
      (setf pop (next-generation sorted-pop repro-policy)))
    (car (car sorted-pop))))

  
#|






|#



